home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / coreFixes.tcl < prev    next >
Encoding:
Text File  |  1999-02-03  |  7.4 KB  |  267 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "coreFixes.tcl"
  6.  #                                    created: 31/7/97 {2:09:16 am} 
  7.  #                                last update: 3/2/99 {10:30:43 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Reorganisation carried out by Vince Darley with much help from Tom 
  15.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  16.  # Alpha is shareware; please register with the author using the register 
  17.  # button in the about box.
  18.  #  
  19.  # This file contains Tcl procs which wrap around or replace
  20.  # core (hard-coded) Alpha procs to fix some bugs they may have.
  21.  # Sadly most core Alpha bugs can't be fixed in this way.
  22.  # 
  23.  # Ultimately, one hopes, these bugs will be fixed and these procs
  24.  # can be removed...
  25.  # ###################################################################
  26.  ##
  27.  
  28. # ◊◊◊◊ Buggy procs ◊◊◊◊ #
  29.  
  30. # so any selections present are maintained
  31. rename centerRedraw __centerRedraw
  32. ;proc centerRedraw {args} {
  33.     lappend selectionEndPoints [getPos] [selEnd]
  34.     uplevel __centerRedraw $args
  35.     eval select $selectionEndPoints 
  36. }
  37.  
  38. # so any selections present are maintained
  39. rename insertToTop __insertToTop
  40. ;proc insertToTop {args} {
  41.     lappend selectionEndPoints [getPos] [selEnd]
  42.     uplevel __insertToTop $args
  43.     eval select $selectionEndPoints 
  44. }
  45.  
  46. # not really a 'fix', but it's much more efficient in many places if
  47. # you can set the mode of a window in advance  ---- else you switch
  48. # modes twice on opening the window!  This version of 'new' has a new
  49. # flag '-m' which lets you set the mode.  It also returns the name
  50. # of the window which was really opened.  Any additional flags received
  51. # by this proc are assumed to be arguments to be passed to 'setWinInfo',
  52. # except without the leading '-'.  So, for instance you can do:
  53. #     new -n "blah" -tabsize 4 -shell 1
  54. # Also args '-text' to set the text, or a useful new flag '-info'
  55. # which takes the text as the next arg, and automatically sets the
  56. # window to a read-only shell window, and scrolls to the top after
  57. # inserting the given text.  Useful for all those 'info' windows Alpha
  58. # uses!
  59. rename new __new
  60. ;proc new {args} {
  61.     set i 0
  62.     set where {}
  63.     while {[set arg [lindex $args $i]] != ""} {
  64.     incr i
  65.     switch -- $arg {
  66.         "-n" { 
  67.         set name [lindex $args $i]
  68.         incr i
  69.         }
  70.         "-g" { 
  71.         eval lappend where "-g" [lrange $args $i [incr i 3]]
  72.         incr i
  73.         }
  74.         "-m" { 
  75.         set mode [lindex $args $i]
  76.         set mi $i
  77.         incr i
  78.         }
  79.         default {
  80.         set other($arg) [lindex $args $i]
  81.         incr i
  82.         }
  83.     }
  84.     }
  85.     if {![info exists name]} {
  86.     set name "Untitled"
  87.     }
  88.     set newname $name
  89.     
  90.     if {[lsearch -exact [winNames -f] $name] != -1} {
  91.     set i 2
  92.     while {[lsearch -exact [winNames -f] "$name <$i>"] != -1} {
  93.         incr i
  94.     }
  95.     append name " <${i}>"
  96.     }
  97.     if {[info exists mode]} {
  98.     global win::Modes
  99.     set win::Modes($name) $mode
  100.     }
  101.     global alpha::platform
  102.     if {${alpha::platform} != "alpha"} {
  103.     eval __new -n [list $name] $where
  104.     } else {
  105.     eval __new -n [list $newname] $where
  106.     }
  107.     if {![info exists mode]} { 
  108.     set name [win::Current]
  109.     }
  110.     if {[info exists other(-info)]} {
  111.     setWinInfo -w $name shell 1
  112.     insertText $other(-info)
  113.     setWinInfo -w $name read-only 1
  114.     goto [minPos]
  115.     unset other(-info)
  116.     }
  117.     # We must do shell first, then text, then dirty and then others
  118.     # in any order.  Else we'd get errors like can't make window read-only
  119.     # when dirty if they were in the wrong order...
  120.     if {[info exists other(-shell)]} {
  121.     setWinInfo -w $name shell $other(-shell)
  122.     unset other(-shell)
  123.     }
  124.     if {[info exists other(-text)]} {
  125.     insertText $other(-text)
  126.     unset other(-text)
  127.     }
  128.     if {[info exists other(-dirty)]} {
  129.     setWinInfo -w $name dirty $other(-dirty)
  130.     unset other(-dirty)
  131.     }
  132.     if {[info exists other]} {
  133.     foreach a [array names other] {
  134.         setWinInfo -w $name [string range $a 1 end] $other($a)
  135.     }
  136.     }
  137.     return $name 
  138. }
  139.  
  140. # If the position to blink is offscreen, show a message with context
  141. rename blink __blink
  142. ;proc blink {pos} {
  143.     __blink $pos
  144.     getWinInfo w
  145.     if {[info exists w(currline)]} {
  146.     set topl $w(currline)
  147.     set endl [expr {$topl + $w(linesdisp)}]
  148.     scan [posToRowCol $pos] "%d %d" row col
  149.     if {$row < $topl || $row >= $endl} {
  150.         message "Matching '[getText [lineStart $pos] [pos::math $pos + 1]]'"
  151.     }
  152.     }
  153. }
  154.  
  155. # keep window vertical position the same
  156. rename revert __revert
  157. ;proc revert {args} {
  158.     getWinInfo w
  159.     set topl $w(currline)
  160.     uplevel __revert $args
  161.     display [rowColToPos $topl 0]
  162. }
  163.  
  164. rename print __print
  165. ;proc print {args} {
  166.     # make sure we've got our procs loaded, else Alpha can't print
  167.     catch {printLeftHeader}
  168.     catch {printRightHeader}
  169.     if {[llength $args]} {
  170.     if {[catch __print [lindex $args 0]]} {
  171.         file::openQuietly [lindex $args 0]
  172.         uplevel __print
  173.     } 
  174.     } else {
  175.     uplevel __print
  176.     }
  177. }
  178.  
  179. # ◊◊◊◊ Procs fixed in Alpha 8 ◊◊◊◊ #
  180.  
  181. if {[info tclversion] >= 8.0} {
  182.     # We just have this proc to help people who haven't updated their code
  183.     # to use Tcl 8's native routines.  It will vanish eventually.
  184.     ;proc mkdir {dir} {
  185.     file mkdir $dir
  186.     }
  187.     return
  188. }
  189.  
  190. # old version is a bit picky
  191. if {![string length [info commands __cd]]} {
  192.     rename cd __cd
  193. }
  194. ;proc cd args {
  195.     if {$args == ".."} { set args "::" }
  196.     if {$args == "."} { set args ":" }
  197.     if {[llength $args]} {
  198.     set path [string trim [eval list $args] "        \{\}"]
  199.     if {![regexp {:$} $path]} { append path ":" }
  200.     if {![file isdir $path] && [file isdir [pwd]$path]} {
  201.         set path ":$path"
  202.     }
  203.     __cd $path
  204.     } else {
  205.     global HOME
  206.     __cd $HOME
  207.     }
  208. }
  209.  
  210. # fix for Alpha trapping command clicks on lines which contain ':'
  211. # unnecessarily.
  212. rename icURL __icURL
  213. ;proc icURL {args} {
  214.     if {[catch {eval __icURL $args}]} {
  215.     set mods [getModifiers]
  216.     # Alpha highlights the wrong piece of text, so find mouse pos
  217.     # and generate a new piece position
  218.     if {![catch {mousePos} pos]} {
  219.         goto [eval rowColToPos $pos]
  220.     }
  221.     cmdDoubleClick -1 -1 \
  222.       [expr {$mods & 34}] [expr {$mods & 72}] [expr {$mods & 144}]
  223.     }
  224. }
  225. # bring to front does nothing if already foremost 
  226. # (the original calls activateHook, changeMode....)
  227. rename bringToFront __bringToFront
  228. ;proc bringToFront {name} {
  229.     global win::Current
  230.     if {[file tail $name] != [file tail ${win::Current}]} { 
  231.     __bringToFront $name 
  232.     }
  233. }
  234.  
  235. # if you select a directory from inside it, it has a ':', if you select
  236. # from outside, it doesn't have a colon.  There is another problem, which
  237. # is that Alpha won't let you select a volume, only a folder within a 
  238. # volume, but I haven't fixed that here.
  239. rename get_directory __get_directory
  240. ;proc get_directory {args} {
  241.     set dir [eval __get_directory $args]
  242.     regsub {:$} $dir {} dir
  243.     return $dir
  244. }
  245.  
  246.  
  247. # Setting fonts and tabs doesn't need to dirty the window
  248. rename setFontsTabs __setFontsTabs
  249. ;proc setFontsTabs {args} {
  250.     set d [winDirty]
  251.     uplevel __setFontsTabs $args
  252.     if {!$d && [winDirty]} {
  253.     setWinInfo dirty 0
  254.     }
  255. }
  256.  
  257. # Fixes two bugs: the message in the status window was incorrect (shows
  258. # the search, not replace string.  Also a replace string of nothing was
  259. # rejected.
  260. rename enterReplaceString ""
  261. ;proc enterReplaceString {} {
  262.     set t [getSelect]
  263.     replaceString $t
  264.     message "Entered replace '$t'"
  265. }
  266.  
  267.